home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 12c.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  38KB  |  1,285 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* chapter 12, part c */
  10. #include "hdr.h"
  11. #include "vars.h"
  12. #include "attr.h"
  13. #include "dbxp.h"
  14. #include "dclmapp.h"
  15. #include "miscp.h"
  16. #include "smiscp.h"
  17. #include "setp.h"
  18. #include "nodesp.h"
  19. #include "errmsgp.h"
  20. #include "chapp.h"
  21.  
  22. /* ctype.h needed by desig_to_op */
  23. #include <ctype.h>
  24.  
  25. static Tuple instantiation_code;        /* code from instantiation */
  26. static int instantiation_code_n = 0;    /* current length */
  27.  
  28. static Node instantiate_object(Node, Symbol, Symbolmap);
  29. static int can_rename(Node);
  30. static Tuple flatten_tree(Node);
  31. static int is_discr_ref(Node, Tuple);
  32. static Symbol instantiate_type(Node, Symbol, Symbolmap);
  33. static Symbol valid_type_instance(Symbol, Symbol, Symbolmap);
  34. static Symbol valid_scalar_instance(Symbol, Symbol, Symbolmap);
  35. static void check_actual_constraint(Symbol, Symbol);
  36. static Symbol valid_priv_instance(Symbol, Symbol, Symbolmap);
  37. static Symbol valid_access_instance(Symbol, Symbol, Symbolmap);
  38. static Symbol valid_array_instance(Symbol, Symbol, Symbolmap);
  39. static int is_valid_disc_instance(Symbol, Symbol, Symbolmap);
  40. static Tuple get_array_info(Symbol);
  41. static void generic_subprog_instance(Node, Symbol, Symbolmap, int);
  42. static Tuple find_renamed_types(int, Tuple, Symbol, Node);
  43. static Node make_rename_node(Symbol, Node);
  44. static void instantiation_code_with(Node);
  45.  
  46. /* number of slots to expand instantiation_code when full, initial alloc*/
  47. #define INSTANTIATION_CODE_INC    50
  48.  
  49. Tuple instantiate_generics(Tuple gen_list, Node instance_node)
  50.   /*;instantiate_generics*/
  51. {
  52.     /* Produce the list of renamings which transforms generic parameters
  53.      * into actual ones.
  54.      * Generic types play a special role in this renaming. We collect the
  55.      * Instantiations of generic types into the map     -type_map-and use it
  56.      * in a substitution procedure to obtain the signature of generic
  57.      * subprogram arguments.
  58.      * Generic subprograms are also renamed by the actual subprograms, and
  59.      * the mapping from one to the other is also added to the same renaming
  60.      * map.
  61.      */
  62.  
  63.     Tuple    error_instance, empty_tuple, inst_code;
  64.     Symbolmap    type_map, empty_typemap;
  65.     Tuple    gtup;
  66.     Tuple    instance, new_instance;
  67.     int        i, j, k, gn, ni, seen, same_formal_subprog;
  68.     Node    assoc;
  69.     int        first_named, exists, is_default;
  70.     Symbol    g_name, name, over;
  71.     Node    actual;
  72.     Symbol    actual_type;
  73.     Node    init_node;
  74.     Node    id_node;
  75.     Tuple    tup;
  76.     int        nat;
  77.     Fortup    ft1;
  78.     Forset  fs1;
  79.  
  80.     if( cdebug2 > 3) TO_ERRFILE("AT PROC :  instantiate_generics ");
  81.  
  82.     /*    const error_instance = [ [], {} ];        $$ES7 */
  83.     instantiation_code = tup_new(0);
  84.     instantiation_code_n = 0;
  85.     type_map = symbolmap_new();
  86.     empty_tuple = tup_new(0);
  87.     empty_typemap = symbolmap_new();
  88.     error_instance = tup_new2((char *) empty_tuple, (char *) empty_typemap);
  89.     instance = N_LIST(instance_node);
  90.  
  91.     if (tup_size( instance) > tup_size( gen_list)){
  92.         errmsg("Too many actuals in generic instantiation", "12.3", instance_node);
  93.     }
  94.  
  95.     /* Values may be supplied either positionally or by name.  */
  96.     exists = FALSE;
  97.     FORTUPI(assoc=(Node), instance, i, ft1);
  98.         if (N_AST1(assoc) != OPT_NODE){
  99.             exists = TRUE;
  100.             break;
  101.         }
  102.     ENDFORTUP(ft1);
  103.     if (exists) {
  104.         first_named = i;
  105.         exists = FALSE;
  106.         for (k=i; k <= tup_size(instance); k++) {
  107.             if (N_AST1((Node)instance[k]) == OPT_NODE){
  108.                 exists = TRUE;
  109.                 break;
  110.             }
  111.         }
  112.         if (exists) {
  113.             errmsg("Positional association after named one", "12.3",
  114.               (Node)instance[k]);
  115.             return error_instance;
  116.         }
  117.     }
  118.     else
  119.         first_named = tup_size(instance) + 1;
  120.     seen = first_named - 1;
  121.     new_instance = tup_new(0);
  122.     for (i = 1; i <= seen; i++) {
  123.         actual = N_AST2((Node)instance[i]);
  124.         new_instance = tup_with(new_instance, (char *) actual);
  125.     }
  126.  
  127.     /* Collect named instances in the proper order.*/
  128.     gn = tup_size(gen_list);
  129.     for (i=first_named; i <= gn; i++) {
  130.         gtup = (Tuple) gen_list[i];
  131.         g_name = (Symbol) gtup[1];
  132.         init_node = (Node) gtup[2];
  133.         exists = FALSE;
  134.         ni = tup_size(instance);
  135.         for (j=first_named; j <= ni; j++) {
  136.             id_node = N_AST1((Node) instance[j]);
  137.             if (id_node == OPT_NODE) continue;
  138.             if (streq(N_VAL(id_node), ORIG_NAME(g_name))) {
  139.                 exists = TRUE;
  140.                 break;
  141.             }
  142.         }
  143.         if (exists) {
  144.             actual = N_AST2((Node) instance[j]);
  145.             new_instance = tup_with(new_instance, (char *) actual);
  146.             seen += 1;
  147.  
  148.             if (NATURE(g_name) == na_procedure || 
  149.                 NATURE(g_name) == na_function) {
  150.                name = dcl_get(DECLARED(SCOPE_OF(g_name)), N_VAL(id_node));
  151.                         /*
  152.                          * We must distinguish between generic formal
  153.                          * subprogram and those defined in the generic spec.
  154.                          * We perform the check only on those defined in the
  155.                          * generic spec (i.e. those that have their ALIAS 
  156.                          * field defined.
  157.                          */
  158.                same_formal_subprog = 0;
  159.                FORSET(over = (Symbol), OVERLOADS(name), fs1);
  160.                   if (ALIAS(over)!=(Symbol)0) same_formal_subprog++;
  161.                ENDFORSET(fs1);
  162.                if (same_formal_subprog > 1) 
  163.                    errmsg("named associations not allowed for overloaded names",
  164.                       "12.3(3)", id_node);
  165.             }
  166.             /* Otherwise a default must exist for this generic parameter.*/
  167.             /* Mark the place for use below.*/
  168.         }
  169.         else if (init_node != OPT_NODE ) 
  170.             new_instance = tup_with(new_instance, (char *) OPT_NODE);
  171.         else {
  172.             errmsg_id("Missing instantiation for generic parameter %" ,
  173.               g_name, "12.3", current_node);
  174.             return error_instance;
  175.         }
  176.     }
  177. #ifdef TBSN
  178.     if (cdebug2 > 0){
  179.         TO_ERRFILE('new instance ' + str new_instance);
  180.     }
  181. #endif
  182.     /* Now process all actuals in succession. */
  183.     gn = tup_size(gen_list);
  184.     for (i = 1; i <= gn; i++) {
  185.         gtup= (Tuple) gen_list[i];
  186.         g_name = (Symbol) gtup[1];
  187.         init_node = (Node) gtup[2];
  188.         actual = (Node) new_instance[i];
  189.  
  190.         if (actual != OPT_NODE ) {
  191.             adasem(actual);
  192.             if (NATURE(g_name) == na_in) {
  193.                 /* type check expression for in parameter. */
  194.                 actual_type = replace(TYPE_OF(g_name), type_map);
  195.                 check_type(actual_type, actual);
  196.             }
  197.             else if (NATURE(g_name)== na_procedure
  198.               || NATURE(g_name)== na_function) {
  199.                 /* Actual may be given by an operator symbol, which appear  */
  200.                 /*  as string literal. */
  201.                 is_default = FALSE;
  202.                 if (N_KIND(actual) == as_string_literal)
  203.                     desig_to_op(actual);
  204.                 find_old(actual);
  205.             }
  206.         }
  207.         else {
  208.             /* Use default value given.*/
  209.             actual = init_node;
  210.             if (NATURE(g_name) == na_in )
  211.                 /* May depend on generic types: replace by their instances.*/
  212.                 actual = instantiate_tree(init_node, type_map);
  213.             else    {        /* generic subprogram parameter */
  214.                 /* If the box was used to specify a default subprogram, we
  215.                  * retrieve the visible instances of the generic identifier.
  216.                  */
  217.                 is_default = TRUE;
  218.                 if (N_KIND(actual) == as_simple_name
  219.                   && streq(N_VAL(actual), "box")) {
  220.                     actual = node_new(as_simple_name);
  221.                     N_VAL(actual) = original_name(g_name);
  222.                     copy_span(instance_node, actual);
  223.                     find_old(actual);
  224.                     is_default = FALSE;
  225.                 }
  226.                 else if (N_KIND(actual) == as_attribute)
  227.                     /* Will depend on generic types. Must instantiate. */
  228.                     actual = instantiate_tree(init_node, type_map);
  229.             }
  230.         }
  231.         nat = NATURE(g_name);
  232.         if (nat == na_in || nat == na_inout)
  233.             /* TBSL: see if instantiation_code might be large in which case
  234.              * may want to avoid too many tup_with calls
  235.              */
  236.             instantiation_code_with(
  237.               instantiate_object(actual, g_name, type_map));
  238.         else if (nat == na_procedure || nat == na_function)
  239.             generic_subprog_instance(actual, g_name, type_map, is_default);
  240.         else {            /* generic type. */
  241.             actual_type = instantiate_type(actual, g_name, type_map);
  242.             if (actual_type == (Symbol)0)
  243.                 return error_instance;
  244.             else {
  245.                 symbolmap_put(type_map, g_name, actual_type);
  246.                 if (is_scalar_type(g_name))
  247.                     /* indicate the instantiation of its base type as well. */
  248.                     symbolmap_put(type_map, TYPE_OF(g_name),
  249.                       base_type(actual_type));
  250.             }
  251.         }
  252.     }
  253.     if (seen != tup_size(instance)) {
  254.         /* Not all named associations were processed.*/
  255.         errmsg("duplicate or erroneous named associations in instantiation",
  256.           "12.3", current_node);
  257.     }
  258.  
  259.     if (cdebug2 > 0 ) TO_ERRFILE("Type map: ");
  260.     /* Attach newly created declarative nodes to the instance node itself
  261.      * so that AST tree remains connected (separate compilation need).
  262.      * TBSL: check whether this trick is still necessary now that the node
  263.      * stack (in save_tree) is initialized with all nodes in unit_nodes
  264.      */
  265.     inst_code = tup_new(instantiation_code_n);
  266.     for (i = 1; i <= instantiation_code_n; i++)
  267.         inst_code[i] = instantiation_code[i];
  268.     N_LIST(instance_node) = tup_add(N_LIST(instance_node), inst_code);
  269.     tup = tup_new(2);
  270.     /* TBSL: is tup_copy needed below since i...code also include in N_LIST*/
  271.     tup[1]= (char *) inst_code;
  272.     tup[2] = (char *) type_map;
  273.     return tup;
  274. }
  275.  
  276. void desig_to_op(Node node)            /*;desig_to_op*/
  277. {
  278.     /* a designator appears syntactically as a string literal. Verify that it
  279.      * does designate a valid operator symbol.
  280.      */
  281.  
  282.     char    *op_name, *p;
  283.  
  284.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  desig_to_op");
  285.  
  286.     N_KIND(node) = as_simple_name;
  287.     /*op_name := +/[to_lower(c) ? c : c in N_VAL(node)];*/
  288.     op_name = strjoin(N_VAL(node), ""); /* copy operator name */
  289.     for (p = op_name; *p; p++)  /* fold name to lower case*/
  290.         if (isupper(*p)) *p = tolower(*p);
  291.     if (in_op_designators(op_name))
  292.         N_VAL(node) = (char *) op_name;
  293.     else {
  294.         errmsg_str("% is not an operator designator", op_name, "4.5", node);
  295.         N_VAL(node) = string_any_id; /* "any_id" */
  296.     }
  297. }
  298.  
  299. static Node instantiate_object(Node actual_node, Symbol g_name,
  300.   Symbolmap type_map)                        /*;instantiate_object*/
  301. {
  302.     int        g_mode;
  303.     Symbol    g_type, actual_type;
  304.     Node    d, n, i, t;
  305.     Symbol    actual_name;
  306.     Tuple    tup;
  307.  
  308.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : instantiate_object");
  309.  
  310.     /* Unpack information about generic parameter.*/
  311.     g_mode = NATURE(g_name);
  312.     g_type = TYPE_OF(g_name);
  313.  
  314.     actual_type = symbolmap_get(type_map, g_type);
  315.     /* If generic. */
  316.     if (actual_type == (Symbol)0) actual_type = g_type;
  317.     /* Otherwise. */
  318.     /* For each instantiation we must create locations for the generic
  319.      * parameters, and replace in the body of the object the generic ones
  320.      * with the actual ones.
  321.      */
  322.  
  323. #ifdef TBSN
  324.     actual_name = prefix + original_name(g_name) + str newat;
  325. #endif
  326.     actual_name = sym_new(na_void);
  327.     ORIG_NAME(actual_name) = ORIG_NAME(g_name);
  328.     symbolmap_put(type_map, g_name, actual_name);
  329.  
  330.     if (g_mode == na_in) {
  331.         /* Expression has already been type_checked*/
  332.         if (is_deferred_constant(actual_node)) {
  333.             errmsg_l("Instantiation of a generic in parameter cannot be a ",
  334.               " deferred constant", "7.4.3", actual_node);
  335.             return OPT_NODE;
  336.         }
  337.         NATURE(actual_name) = na_constant;
  338.         TYPE_OF(actual_name) = actual_type;
  339.         SIGNATURE(actual_name) = (Tuple) actual_node;
  340.         /* Build declaration tree for it.  */
  341.         d = node_new(as_const_decl);
  342.         n = node_new(as_list);
  343.         i = node_new(as_simple_name);
  344.         t = node_new(as_simple_name);
  345.         N_UNQ(i) = actual_name;
  346.         N_UNQ(t) = actual_type;
  347.         N_LIST(n) = tup_new1((char *) i);
  348.         N_AST1(d) = n;
  349.         N_AST2(d) = t;
  350.         N_AST3(d) = actual_node;
  351.         return  d;
  352.     }
  353.     else {                        /* in out parameter. */
  354.         TYPE_OF(actual_name) = actual_type;
  355.         SIGNATURE(actual_name) = (Tuple) OPT_NODE;
  356.         if (N_KIND(actual_node) != as_name) {
  357.             errmsg(
  358.               "Instantiation of generic in out parameter must be a variable",
  359.               "12.1.1, 12.3.1", actual_node);
  360.             return OPT_NODE;
  361.         }
  362.         else {
  363.             find_old(actual_node);
  364.         }
  365.  
  366.         /*
  367.          * this next test may be superfluous, as is_variable() no longer
  368.          * allows conversions!
  369.          */
  370.         if (N_KIND(actual_node) == as_convert) {
  371.             errmsg_l("Instantiation of generic in out parameter ",
  372.               "cannot be a conversion", "12.3.1", actual_node);
  373.             return OPT_NODE;
  374.         }
  375.         out_context = FALSE;
  376.  
  377.         check_type(base_type(actual_type), actual_node);
  378.         tup = check_nat_type(actual_node);
  379.         NATURE(actual_name) = (int) tup[1];
  380.         SCOPE_OF(actual_name) = scope_name;
  381.  
  382.         /* actual_name carries the type of the actual, not the renamed formal.*/
  383.         /* remove spurious constraint that may have been imposed by check_type*/
  384.  
  385.         if (in_qualifiers(N_KIND(actual_node)))
  386.             actual_node = N_AST1(actual_node);
  387.         if (N_KIND(actual_node) == as_simple_name)
  388.             /* should deal with general name here. */
  389.             TYPE_OF(actual_name) = TYPE_OF(N_UNQ(actual_node));
  390.  
  391.         if (!is_variable(actual_node)){
  392.             errmsg_l("Instantiation of generic in out parameter ",
  393.               "must be a variable", "12.1.1, 12.3.1", actual_node);
  394.             return OPT_NODE;
  395.         }
  396.         /*TBSL: SETL has is_dis(actual), substituting actual_node */
  397.         else if ( ! can_rename( actual_node )) {
  398.             errmsg_l_id(
  399.               "instantiation of generic in out parameter % depends on a ",
  400.               "discriminant", g_name, "12.3.1", actual_node);
  401.             return OPT_NODE;
  402.         }
  403.         else {
  404.             /* Build a renaming declaration for object.
  405.              * Possible optimization if actual is simple name (later).
  406.              */
  407.             d = node_new(as_rename_obj);
  408.             i = new_name_node(actual_name);
  409.             N_AST1(d) = i;
  410.             N_AST2(d) = OPT_NODE;
  411.             N_AST3(d) = actual_node;
  412.             return d;
  413.         }
  414.     }
  415. }
  416.  
  417. static int can_rename(Node obj)                        /*;can_rename */
  418. {
  419.     /* This procedure detects illegal  dependence on discriminants for renamed
  420.      * variables  and in out  generic parameters, as  defined  in 8.5(7).  The
  421.      * expression is  linearized  and subsequent retrievals examined to detect
  422.      * subcomponents whose existence depends on outer discriminants. The first
  423.      * retrieval is the only  one that can apply to an unconstrained variable.
  424.      */
  425.  
  426.     Tuple    seq, discrs, discr_map;
  427.     Node    var_node, sel_node, first, node, lo, hi;
  428.     Symbol    var_name, var_type, selector, comp_type, i;
  429.     int    d, dsize;
  430.     Fortup    ft;
  431.  
  432.     seq = (Tuple) flatten_tree(obj);
  433.     if (tup_size(seq) == 0) return TRUE;
  434.     first = (Node) seq[tup_size(seq)];
  435.  
  436.     var_node = N_AST1(first);
  437.     sel_node = N_AST2(first);
  438.  
  439.     /* The first prefix is a simple name, an allocator, or a function call.
  440.      * We only consider simple names here.
  441.      */
  442.     if (N_KIND(var_node) != as_simple_name ) return TRUE;
  443.  
  444.     var_name = N_UNQ(var_node);
  445.     var_type = TYPE_OF(var_name);
  446.  
  447.     if ( can_constrain(var_type)) {
  448.         /* Any dependence on its discriminants will be illegal.
  449.          * TBSL: a generic in out parameter.
  450.          */
  451.         discrs = discriminant_list(var_type);
  452.         if (is_formal(var_name) ) {
  453.             FORTUP(i=(Symbol), discrs, ft)
  454.                 if (default_expr(i) == (Tuple) OPT_NODE) {
  455.                     discrs = tup_new(0);
  456.                     break;
  457.                 }
  458.             ENDFORTUP(ft);
  459.         }
  460.     }
  461.     else
  462.         discrs = tup_new(0);
  463.  
  464.     /* other dependence is if subtype indication of subcomponent
  465.     * depends on discriminants of variable, or on discriminants of
  466.     * inner constrainable components.
  467.     */
  468.     while (tup_size(seq) != 0) {
  469.         node = (Node) tup_frome(seq);
  470.         if (N_KIND(node) == as_selector) {
  471.             sel_node = N_AST2(node);
  472.             comp_type = TYPE_OF(N_UNQ(sel_node));
  473.         }
  474.         else
  475.             /* other subcomponents cannot depend on discriminants */
  476.             return TRUE;
  477.         selector = N_UNQ(sel_node);
  478.         if (tup_size(discrs) != 0 && !tup_mem((char *)selector,
  479.           build_comp_names((Node) invariant_part(var_type))))
  480.             /* component is in variant part: illegal renaming. */
  481.             return FALSE;
  482.         if (is_array(comp_type)) {
  483.             FORTUP(i=(Symbol), index_types(comp_type), ft)
  484.                 lo = (Node) SIGNATURE(i)[2];
  485.                 hi = (Node) SIGNATURE(i)[3];
  486.                 if (is_discr_ref(lo, discrs) || is_discr_ref(hi, discrs))
  487.                     return FALSE;
  488.             ENDFORTUP(ft);
  489.         }
  490.         else if (is_record(comp_type)) {
  491.             if (NATURE(comp_type) == na_subtype) {
  492.                 discr_map = (Tuple) numeric_constraint_discr(
  493.                   SIGNATURE(comp_type));
  494.                 /* if exists node in range discr_map |
  495.                  *    is_discr_ref(node, discrs) then     return false; end if;
  496.                  */
  497.                 dsize = tup_size(discr_map);
  498.                 for (d = 1; d <= dsize; d += 2 ) {
  499.                     node = (Node) discr_map[d+1];
  500.                     if (is_discr_ref(node, discrs))
  501.                         return FALSE;
  502.                 }
  503.                 discrs = tup_new(0);
  504.             }
  505.             else    {
  506.                 discrs = discriminant_list(comp_type);
  507.                 var_type = comp_type;  /* for inner subcomponents */
  508.             }
  509.         }
  510.         else return TRUE;        /* scalar component */
  511.     }
  512.     /* If we exit, no discriminant dependence was found. */
  513.     return TRUE;
  514. }
  515.  
  516. static Tuple flatten_tree(Node expn)                /*;flatten_tree */
  517. {
  518.     /* In order to determine whether a subcomponent depends on a discriminant,
  519.      * it is easiest  to simulate  in order     the sequence of  retrievals  that
  520.      * yields that subcomponent. Only nodes that retrieve  components are kept.
  521.      */
  522.  
  523.     Node prefix;
  524.     int kind;
  525.  
  526.     kind = N_KIND(expn);
  527.     if (kind == as_selector ||kind == as_index || kind == as_slice) {
  528.         prefix = N_AST1(expn);
  529.         return (tup_add(tup_new1((char *)expn), flatten_tree(prefix)));
  530.     }
  531.     else
  532.         return tup_new(0);
  533. }
  534.  
  535. static int is_discr_ref(Node node, Tuple discrs)        /*;is_discr_ref */
  536. {
  537.  
  538.     if (N_KIND(node) != as_discr_ref)
  539.         return FALSE;
  540.     else
  541.         return tup_mem((char *) N_UNQ(node), discrs);
  542. }
  543.  
  544. /* THIS IS OBSOLETE !!! */
  545. int is_discriminant_dependent(Node  expn)  /*;is_discriminant_dependent*/
  546. {
  547.     /*   Function :
  548.      *     this (non-recursive) procedure accepts as parameter an
  549.      *     expression that has been parsed as a valid 'name', and
  550.      *     return true if the existence of the object designated
  551.      *     may depend on a discriminant. See LRM 8.5, 3.7.1, 12.3.1.
  552.      *   Usage :
  553.      *     for generic in out parameter
  554.      *     for renaming
  555.      */
  556.  
  557. /*  comment out for less warning messages from  CC
  558.     Tuple    lexpn;
  559.     Symbol    first;
  560.     int        is_first_element;
  561.     Symbol    current_type;
  562.     Tuple    discr;
  563.     Symbol    op_name, base_type_rec, field_name, name;
  564.     Tuple    nam_list;
  565.     Tuple    bounds;
  566.     Symbol    i;
  567. */
  568.     /* lo, hi, bound */
  569.  
  570.     if (cdebug2 > 3)
  571.         TO_ERRFILE("AT PROC : is_discriminant_dependent ( + str expn + )");
  572.  
  573.     return    FALSE;      /* $$$ FOR NOW */
  574.     /*****************************************************/
  575.     /*   the expression is first 'flattened' : */
  576.  
  577.     /* Ihave changed expn to lexpn as lexpn must be flattened */
  578. #ifdef TBSN
  579.     lexpn = linear(expn);
  580.     first fromb lexpn;
  581.     is_first_element =  TRUE;
  582.     current_type = TYPE_OF( first );
  583.     discr = tup_new(0);
  584.  
  585.     /*  the guess along that loop is that it is not dependent : */
  586.     ( while (lexpn?[]) /= [] )
  587.     case op_name fromb lexpn of
  588.  
  589.         /*
  590.  *  Record case : check that component is in fixed part
  591.  *          keep discriminants in case of array component
  592.  */
  593.         ('.'):
  594. base_type_rec :
  595.             = base_type ( current_type );
  596.     field_name fromb lexpn;
  597. *$ES147  field_name :
  598.     = declared_components(base_type_rec)(field_name);
  599.     if ((nature ( current_type ) == 'subtype') ||
  600.         /*
  601.  *  if it is a formal parameter of some unconstrained type, the actual
  602.  *  parameter must have been constrained...
  603.  */
  604.     (        is_first_element
  605.         && is_formal ( first )
  606.         && is_unconstrained ( current_type ))){
  607. discr :
  608.         = discriminant_list ( base_type_rec );
  609. else
  610.     if (not exists
  611.         [ -, nam_list, - ] in invariant_part ( base_type_rec ) ,
  612.         name in nam_list | name = field_name ){
  613.         return TRUE;
  614.     }
  615. discr :
  616. = [];
  617.     }
  618. current_type :
  619.     = type_of ( field_name );
  620.  
  621.     /*
  622.  * Array or Slice case : if bound is dynamic, is must be constrained
  623.  */
  624.     ('[]', '[..]'):
  625.     *$ES147 (
  626. bounds :
  627.         = [];
  628.         (for i in index_types(current_type))
  629. [-, low, high] :
  630.         = signature (i);
  631. bounds +:
  632.         = [low, high];
  633.         end for;
  634.         if( exists bound in bounds || is_tuple(bound)
  635.         && (bound(1) = 'discr_rep')  && (bound(2) notin discr)){
  636.         return TRUE;
  637.     }
  638.  
  639.     if (op_name == '[]'){
  640. current_type :
  641.         = component_type ( current_type );
  642.     }
  643.  
  644.     *$ES147 )
  645.         /*
  646.  * Access case : cannot depend on a discriminant !
  647.  * Function call : idem
  648.  */
  649.     ('@', 'call'):
  650.     return     FALSE;
  651.  
  652.     /*
  653.  * Possible gap here
  654.  */
  655. else
  656.     return     FALSE;
  657. end case;
  658. is_first_element :
  659. =  FALSE;
  660.  
  661. }
  662.  
  663. return  FALSE; /* $ the initial guess */
  664.  
  665. #endif
  666. }
  667.  
  668. void linear(Symbol  expn ) /*;linear*/
  669. {
  670. /*  comment out for less warning messages from  CC
  671.     Symbol    op_name;
  672.     Symbol    exp1, exp2;
  673. */
  674.  
  675.     /*   Recursive function used by 'is_discriminant_dependent' to
  676.      *   flatten its argument. The grammar of interest for expn is :
  677.      *     expn ::= identifier
  678.      *           |  '.' rec_expr field_name
  679.      *           |  '[]' arr_expr index
  680.      *           |  '[..]' arr_expr slice
  681.      *           |  '@' expr
  682.      *           |  'call' identifier
  683.      */
  684.     chaos("linear(12) not implemented");
  685. #ifdef TBSN
  686.     if (is_identifier ( expn ) ){
  687.         return [ expn ];
  688.     }
  689.     else{
  690. [ op_name, exp1, exp2 ] :
  691.         = expn;
  692.     case op_name of
  693.         ('.'):
  694.         return linear(exp1)+[op_name]+linear(exp2);
  695.         ('[]', '[..]', '@', 'call'):
  696.         return linear(exp1)+[op_name];
  697. else
  698.     return [];
  699. end case;
  700.     }
  701. #endif
  702. }
  703.  
  704. static Symbol instantiate_type(Node type_node, Symbol g_name,Symbolmap type_map)
  705.   /*;instantiate_type*/
  706. {
  707.     /* Validate the     instantiation of a generic  type. The    actual must be
  708.      * a type mark.
  709.      */
  710.  
  711.     Symbol    actual_type;
  712.     int        nk;
  713.  
  714.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  instantiate_type");
  715.  
  716.     nk = N_KIND(type_node);
  717.     if (nk == as_name || nk == as_simple_name){
  718.         find_type(type_node);
  719.         actual_type = N_UNQ(type_node);
  720.         if (actual_type == symbol_any)                /* Not a type */
  721.             return (Symbol)0;
  722.         else 
  723.             return valid_type_instance(g_name, actual_type, type_map);
  724.     }
  725.     else{
  726.         errmsg_id("invalid expression for instantiation of %", g_name,
  727.           "12.3", current_node);
  728.         return (Symbol)0;
  729.     }
  730. }
  731.  
  732. static Symbol valid_type_instance(Symbol g_name, Symbol actual_type,
  733.   Symbolmap type_map)                        /*;valid_type_instance*/
  734. {
  735.     if (is_scalar_type(g_name))
  736.         return valid_scalar_instance(g_name, actual_type, type_map);
  737.     else if (is_access(g_name))
  738.         return valid_access_instance(g_name, actual_type, type_map);
  739.     else if (is_array(g_name))
  740.         return  valid_array_instance(g_name, actual_type, type_map);
  741.     else
  742.         return valid_priv_instance(g_name, actual_type, type_map);
  743. }
  744.  
  745. static Symbol valid_scalar_instance(Symbol g_name, Symbol actual_type,
  746.   Symbolmap type_map)                        /*;valid_scalar_instance*/
  747. {
  748.     /* Complete the validation of the instantiation of a generic scalar type.
  749.      * This procedure is also used to emit constraint checks on access types
  750.      * and array types.
  751.      */
  752.  
  753.     Symbol    g_type;
  754.  
  755.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : valid_scalar_instance");
  756.  
  757.     g_type = root_type(g_name); /*INTEGER, FLOAT, $FIXED, etc.*/
  758.     if (g_type == root_type(actual_type) && is_generic_type(g_name))
  759.         return actual_type;
  760.     else if (base_type(g_type) == base_type(actual_type)){
  761.         /* Checking instantiation of the designated type of an access type
  762.          * or  index type of an  array type. Verify that constraints match.
  763.          */
  764.         check_actual_constraint(g_name, actual_type);
  765.         return actual_type;
  766.     }
  767.     else if  ((is_fixed_type(g_type) && is_fixed_type(actual_type))
  768.       || (g_type == symbol_discrete_type  && is_discrete_type(actual_type)))
  769.         return actual_type;
  770.     else {
  771.         errmsg_id("Invalid type for instantiation of %", g_name,
  772.           "12.3.2 - 12.3.5", current_node);
  773.         return (Symbol)0;
  774.     }
  775. }
  776.  
  777. static void check_actual_constraint(Symbol g_type, Symbol a_type)
  778.   /*;check_actual_constraint*/
  779. {
  780.     /* Verify that the constraint on the designated type of an access type,
  781.      * or an index type of an array type, match the constraints on the cor-
  782.      * responding formal generic type. The types are known to be compatible.
  783.      */
  784.  
  785.     Node    n, d, g, a, t;
  786.     Tuple    g_discr_map, g_list, a_list;
  787.     Symbol    discr;
  788.     Tuple    g_info, a_info;
  789.     int        i;
  790.     Tuple    tup;
  791.     Fortup    ft;
  792.  
  793.     if (is_scalar_type(g_type)){
  794.         if (g_type == a_type) return;   /* simplest optimization. */
  795.         n = node_new(as_check_bounds);
  796.         g = new_name_node(g_type);
  797.         a = new_name_node(a_type);
  798.         N_AST1(n) = g;
  799.         N_AST2(n) = a;
  800.         instantiation_code_with(n);
  801.     }
  802.     else if (is_record(g_type)  && NATURE(g_type) == na_subtype){
  803.         /* Check that discriminants match.  */
  804.         if (NATURE(a_type) != na_subtype)
  805.             /* Mismatch was already signalled.  */
  806.             return;
  807.  
  808.         tup = SIGNATURE(g_type);
  809.         /* Compare the values of each discriminant. */
  810.         g_list = discriminant_list(base_type(g_type));
  811.         a_list = discriminant_list(base_type(a_type));
  812.         g_discr_map = (Tuple) SIGNATURE(g_type)[2];
  813.  
  814.         FORTUPI(discr=(Symbol), g_list, i, ft)
  815.             n = node_new(as_check_discr);
  816.             t = new_name_node(a_type);
  817.             d = new_name_node((Symbol) a_list[i]);
  818.             N_AST1(n) = discr_map_get(g_discr_map, discr);
  819.             N_AST2(n) = t;
  820.             N_AST3(n) = d;
  821.             instantiation_code_with(n);
  822.         ENDFORTUP(ft);
  823.     }
  824.     else if (is_array(g_type)) {
  825.         g_info = (Tuple) get_array_info(g_type);
  826.         a_info = (Tuple) get_array_info(a_type);
  827.  
  828.         for (i = 1; i <= tup_size(g_info); i++)
  829.             check_actual_constraint((Symbol) g_info[i], (Symbol) a_info[i]);
  830.     }
  831.     else if (is_access(g_type) )
  832.         check_actual_constraint(designated_type(g_type),
  833.           designated_type(a_type));
  834. }
  835.  
  836. static Symbol valid_priv_instance(Symbol g_name, Symbol actual_type,
  837.   Symbolmap type_map)                                /*;valid_priv_instance*/
  838. {
  839.     Symbol    g_type, actual_base;
  840.  
  841.     g_type = TYPE_OF(g_name);
  842.     actual_base = base_type(actual_type);
  843.  
  844.     if (TYPE_OF(actual_base) == symbol_incomplete){
  845.         errmsg_id("Invalid use of incomplete type in instantiation of %",
  846.           g_name, "12.3", current_node);
  847.         return (Symbol)0;
  848.     }
  849.     else if (private_ancestor(actual_base) != (Symbol)0 ){
  850.         errmsg_id("Invalid use of private type in instantiation of %" , g_name,
  851.           "12.3", current_node);
  852.         return (Symbol)0;
  853.     }
  854.     else if (g_type == symbol_private && is_limited_type(actual_type)) {
  855.         errmsg_id("Expect non-limited type to instantiate %" , g_name,
  856.           "12.3.2", current_node);
  857.         return (Symbol)0;
  858.     }
  859.     else if (is_record(g_name) && has_discriminants(g_name)
  860.         /*TBSL: check precdeence of next expr */
  861.       && (!is_record(actual_base) || !has_discriminants(actual_base)
  862.       || !is_valid_disc_instance(g_name, actual_base, type_map))) {
  863.         errmsg_id("discriminant mismatch in instantiation of %", g_name,
  864.           "12.3.2", current_node);
  865.         return (Symbol)0;
  866.     }
  867.     else if (has_discriminants(g_name) && NATURE(actual_type) == na_subtype) {
  868.         errmsg_id("Instantiation of % must be unconstrained", g_name,
  869.           "12.3.2", current_node);
  870.         return (Symbol)0;
  871.     }
  872.  
  873.     else if ((TA_CONSTRAIN & (int)misc_type_attributes(g_name))
  874.         /* The predefined packages cannot perform I/O on unconstrained
  875.          * types. This is caught explicitly here.
  876.          */
  877.       || streq(original_name(SCOPE_OF(g_name)) , "SEQUENTIAL_IO")
  878.       || streq(original_name(SCOPE_OF(g_name)) , "DIRECT_IO" )) {
  879.         if (is_unconstrained(actual_type)) {
  880.             errmsg_l_id("Usage of private type % requires instantiation with",
  881.               " constrained type", g_name, "12.3.2", current_node);
  882.             return (Symbol)0;
  883.         }
  884.         else if (is_generic_type(actual_type)) {
  885.             /* instantiation of this actual will also have to be constrained
  886.              *    (see ACV test BC3205FB)
  887.              */
  888.             misc_type_attributes(actual_type) |= TA_CONSTRAIN;
  889.         }
  890.     }
  891.     return actual_type;
  892. }
  893.  
  894. static Symbol valid_access_instance(Symbol g_name, Symbol actual_type,
  895.   Symbolmap type_map)                        /*;valid_access_instance*/
  896. {
  897.     Symbol    g_type, designated_formal, designated_actual;
  898.  
  899.     g_type = (Symbol) designated_type(g_name);
  900.  
  901.     if (is_access(actual_type)){
  902.         /* the accessed actual type must be the proper instantiation
  903.            * of the accessed generic.
  904.            */
  905.         designated_formal = symbolmap_get(type_map, g_type);
  906.         if(designated_formal == (Symbol)0) designated_formal = g_type;
  907.         designated_actual = (Symbol) designated_type(actual_type);
  908.  
  909.         if (base_type(designated_formal) != base_type(designated_actual)) {
  910.             errmsg_id_id("expect access to % to instantiate %" ,
  911.               designated_formal, g_name, "12.3.3", current_node);
  912.             return (Symbol)0;
  913.         }
  914.         if (is_access(designated_formal)){
  915.             designated_formal = (Symbol) designated_type(designated_formal);
  916.             designated_actual = (Symbol) designated_type(designated_actual);
  917.         }
  918.         if ((can_constrain(designated_formal)
  919.           != can_constrain(designated_actual))){
  920.             errmsg_l("formal and actual designated types must be both ",
  921.               "constrained or unconstrained", "12.3.3", current_node);
  922.             return (Symbol)0;
  923.         }
  924.         check_actual_constraint(designated_formal, designated_actual);
  925.  
  926.         return actual_type;
  927.     }
  928.     else{
  929.         errmsg_id("Expect access type to instantiate %", g_name, "12.3.5",
  930.           current_node);
  931.         return (Symbol)0;
  932.     }
  933. }
  934.  
  935. static Symbol valid_array_instance(Symbol g_name, Symbol actual_type,
  936.   Symbolmap type_map)                        /*;valid_array_instance*/
  937. {
  938.     Symbol    g_type, g_comp, a_comp, t;
  939.     int        i;
  940.     Tuple    g_info, a_info, new_info;
  941.     int        exists;
  942.     Fortup    ft1;
  943.     g_type = TYPE_OF(g_name);
  944.  
  945.     if ( !is_array(actual_type)) {
  946.         errmsg_id("Expect array type to instantiate %", g_name, "12.3.4",
  947.           current_node);
  948.         return (Symbol)0;
  949.     }
  950.     else if (can_constrain(actual_type) && !can_constrain(g_name)){
  951.         errmsg_id("Expect constrained array type to instantiate %", g_name,
  952.           "12.3.4", current_node);
  953.         return (Symbol)0;
  954.     }
  955.     else if (!can_constrain(actual_type) && can_constrain(g_name)){
  956.         errmsg_id("Expect unconstrained array type to instantiate %", g_name,
  957.           "12.3.4", current_node);
  958.     }
  959.     else if (no_dimensions(actual_type) != no_dimensions(g_type)) {
  960.         errmsg_id("Dimensions of actual type do not match those of %", g_name,
  961.           "12.3.4", current_node);
  962.         return (Symbol)0;
  963.     }
  964.     else{
  965.         /* Collect index types and component type. */
  966.         g_info = get_array_info(g_type);
  967.         a_info = get_array_info(actual_type);
  968.         new_info = tup_new(tup_size(g_info));
  969.         FORTUPI(t=(Symbol), g_info, i, ft1);
  970.             new_info[i] = (char *) replace(t, type_map);
  971.         ENDFORTUP(ft1);
  972.         g_comp = (Symbol) new_info[tup_size(new_info)];
  973.         a_comp = (Symbol)a_info[tup_size(a_info)];
  974.  
  975.         exists = FALSE;
  976.         FORTUPI(t=(Symbol), new_info, i, ft1);
  977.             if (!compatible_types(t, (Symbol) a_info[i])) {
  978.                 exists = TRUE;
  979.                 break;
  980.             }
  981.         ENDFORTUP(ft1);
  982.         if (exists) {
  983.             errmsg_l_id("index or component type mismatch in instantiation",
  984.               " of array type %", g_name, "12.3.4", current_node);
  985.             return (Symbol)0;
  986.         }
  987.         /* Check components. */
  988.         else if  (is_access(g_comp)     ?
  989.           can_constrain(designated_type(g_comp)) !=
  990.           can_constrain(designated_type(a_comp))
  991.           : can_constrain(g_comp) !=can_constrain(a_comp) ) {
  992.             errmsg_l("formal and actual array component type must be both ",
  993.               "constrained or unconstrained", "12.3.4", current_node);
  994.             return (Symbol)0;
  995.         }
  996.         else {
  997.             for (i = 1; i <= tup_size(new_info); i++)
  998.                 check_actual_constraint((Symbol)new_info[i],(Symbol) a_info[i]);
  999.             return actual_type;
  1000.         }
  1001.     }
  1002. }
  1003.  
  1004. static int is_valid_disc_instance(Symbol g_name, Symbol a_name,
  1005.   Symbolmap type_map)                            /*;is_valid_disc_instance*/
  1006. {
  1007.     /* checks that the formal and actual discriminant lists match in type
  1008.      * and position.
  1009.      */
  1010.  
  1011.     Tuple    g_list, a_list;
  1012.     Symbol    ad, gd;
  1013.     int        i;
  1014.     Symbol    t;
  1015.     Fortup    ft1;
  1016.     Symbol    gt, at;
  1017.  
  1018.     g_list = (Tuple) discriminant_list(g_name);
  1019.     a_list = (Tuple) discriminant_list(a_name);
  1020.     if (tup_size(g_list) != tup_size(a_list))
  1021.         return FALSE;
  1022.     else{
  1023.         FORTUPI(gd=(Symbol), g_list, i, ft1);
  1024.             ad = (Symbol)a_list[i];
  1025.             t = TYPE_OF(gd);            /* Type of discriminant */
  1026.             gt = symbolmap_get(type_map, t);    /* may be formal generic. */
  1027.             if (gt == (Symbol)0) gt = t;
  1028.             at = TYPE_OF(ad);            /* Base type of actual */
  1029.             if (base_type(gt) != base_type(at))   /* must match. */
  1030.                 return  FALSE;
  1031.             else{
  1032.                 check_actual_constraint(gt, at);    /* and constraints also. */
  1033.                 /* The discriminant names of the formal may have been used
  1034.                  * in a selector in the generic body.They must be mapped into
  1035.                  * the actual discriminants.
  1036.                  */
  1037.                 symbolmap_put(type_map, gd, ad);
  1038.             }
  1039.         ENDFORTUP(ft1);
  1040.     }
  1041.     return    TRUE;
  1042. }
  1043.  
  1044. static Tuple get_array_info(Symbol a_type)            /*;get_array_info*/
  1045. {
  1046.     /* Make sequence of index and component type marks, for comparing a
  1047.      * generic array type with its instantiation.
  1048.      */
  1049.  
  1050.     Tuple    tup;
  1051.  
  1052.     if (cdebug2 > 3 ) TO_ERRFILE("AT PROC :  get_array_info(a_type) ");
  1053.  
  1054.     tup = tup_copy(index_types(a_type));
  1055.     tup = tup_with(tup, (char *) component_type(a_type));
  1056.     return tup;
  1057. }
  1058.  
  1059. static void generic_subprog_instance(Node instance, Symbol g_name,
  1060.   Symbolmap type_map, int is_default)            /*;generic_subprog_instance*/
  1061. {
  1062.     /* Determine the operator, procedure, or attribute which is used to
  1063.      * instantiate a given generic subprogram parameter .
  1064.      *
  1065.      * To validate the new instance, we must first replace generic types by
  1066.      * actual types, to find the  instantiated signature of the  subprogram.
  1067.      */
  1068.  
  1069.     Tuple    new_sig, tup, new_types;
  1070.     Symbol    new_type, proc_name, new_name;
  1071.     Symbol    real_proc, f;
  1072.     Fortup    ft1;
  1073.     int        i;
  1074.  
  1075.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  generic_subprog_instance");
  1076.  
  1077.     if (SIGNATURE(g_name)!=(Tuple)0) {
  1078.         new_sig = tup_new(tup_size(SIGNATURE(g_name)));
  1079.         FORTUPI(f=(Symbol), SIGNATURE(g_name), i, ft1);
  1080.             tup = tup_new(4);
  1081.             tup[1] = ORIG_NAME(f);
  1082.             tup[2] = (char *) NATURE(f);
  1083.             tup[3] = (char *)replace(TYPE_OF(f), type_map);
  1084.             tup[4] = (char *) instantiate_tree((Node) default_expr(f),type_map);
  1085.             new_sig[i] = (char *) tup;
  1086.         ENDFORTUP(ft1);
  1087.     }
  1088.     new_type = replace(TYPE_OF(g_name), type_map);
  1089.     if (cdebug2 > 0 ) TO_ERRFILE("Gen.Subprog. has signature " );
  1090.     if (is_default)
  1091.         new_types = find_renamed_types(NATURE(g_name),
  1092.           new_sig, new_type, instance);
  1093.     else {    /* instantiate using actual */
  1094.         new_types = find_renamed_entity(NATURE(g_name),
  1095.           new_sig, new_type, instance);
  1096.         if (tup_size(new_types) == 0) {        /* renaming error; */
  1097.             errmsg_id("invalid match for generic subprogram %",
  1098.               g_name, "12.3.6", instance);
  1099.             return;
  1100.         }
  1101.     }
  1102.     if (tup_size(new_types) != 0) {        /* no renaming error; */
  1103.         new_type = (Symbol) tup_frome(new_types);
  1104.         FORTUPI(tup=(Tuple), new_sig, i, ft1)
  1105.             tup[3] = new_types[i];
  1106.         ENDFORTUP(ft1)
  1107.     }
  1108.     if (N_KIND(instance) == as_simple_name) {
  1109.         /* It must be the name of an operator or user-defined procedure. */
  1110.         proc_name = N_UNQ(instance);
  1111.  
  1112.         /* instance is a renamed or derived subprogram. Subprogram calls */
  1113.         /* must use the name of the parent subprogram, so:*/
  1114.         if ((real_proc = ALIAS(proc_name)) != (Symbol)0)
  1115.             proc_name = real_proc;
  1116.         symbolmap_put(type_map, ALIAS(g_name), proc_name);
  1117.     }
  1118.     else {
  1119.         /* Instantiation by an attribute or an entry. */
  1120.         new_name = anon_proc_instance(g_name, new_sig, new_type);
  1121.         symbolmap_put(type_map, ALIAS(g_name), new_name);
  1122.         instantiation_code_with(make_rename_node(new_name, instance));
  1123.     }
  1124. }
  1125.  
  1126. static Tuple find_renamed_types(int kind, Tuple formals, Symbol ret,
  1127.   Node name_node)                                /*;find_renamed_types*/
  1128. {
  1129.     /* This procedure is finds the types for the default of a generic
  1130.      * subprogram parameter. In such a case, find_renamed_entity is called
  1131.      * from generic_subp_decl (generic declaration), and if no subprogram
  1132.      * is supplied at instantiation, this procedure is called to determine the
  1133.      * types of the new signature
  1134.      */
  1135.  
  1136.     Symbol    old1, e_name, typ, typ2, res, i;
  1137.     Node        e_node, attr_node, typ_node;
  1138.     int        attr;
  1139.     Tuple    types, tup;
  1140.     Fortup    ft1;
  1141.  
  1142.     types = tup_new(0);
  1143.  
  1144.     switch (N_KIND(name_node)) {
  1145.     case as_simple_name:
  1146.         /* suprogram name renames subprogram name. */
  1147.         old1 = N_UNQ(name_node);
  1148.         if (NATURE(old1) != na_op) {
  1149.             FORTUP(i=(Symbol), SIGNATURE(old1), ft1);
  1150.                 types = tup_with(types, (char *) TYPE_OF(i) );
  1151.             ENDFORTUP(ft1);
  1152.             types = tup_with(types, (char *) TYPE_OF(old1));
  1153.         }
  1154.         else {
  1155.             FORTUP(tup=(Tuple), formals, ft1);
  1156.                 types = tup_with(types, (char *) base_type((Symbol) tup[3]));
  1157.             ENDFORTUP(ft1);
  1158.             types = tup_with(types, (char *) base_type(ret));
  1159.         }
  1160.         break;
  1161.     case as_entry_name:
  1162.         /* Procedure renames a entry given by a qualified name. Find */
  1163.         /* the full entry (and task) name. */
  1164.         e_node = N_AST2(name_node);
  1165.         if (e_node != OPT_NODE) {
  1166.             e_name = N_UNQ(e_node);
  1167.             FORTUP(i=(Symbol), SIGNATURE(e_name), ft1)
  1168.                 types = tup_with(types, (char *) TYPE_OF(i) );
  1169.             ENDFORTUP(ft1)
  1170.             types = tup_with(types, (char *) symbol_none);
  1171.         }
  1172.         break;
  1173.     case as_attribute:
  1174.         /* The name can be an attribute, renaming a function. */
  1175.         attr_node = N_AST1(name_node);
  1176.         typ_node = N_AST2(name_node);
  1177.         attr = (int) attribute_kind(name_node);
  1178.         typ     = N_UNQ(typ_node);
  1179.         /* Find type returned by the attribute, and the required type of its
  1180.          * second argument.
  1181.          */
  1182.         if (attr == ATTR_SUCC || attr == ATTR_PRED) {
  1183.             typ2 = base_type(typ);
  1184.             res = base_type(typ);
  1185.         }
  1186.         else if (attr == ATTR_IMAGE) {
  1187.             typ2 = base_type(typ);
  1188.             res = symbol_string;
  1189.         }
  1190.         else if (attr == ATTR_VALUE) {
  1191.             typ2 = symbol_string;
  1192.             res = base_type(typ);
  1193.         }
  1194.         types = tup_new(2);
  1195.         types[1] = (char *) typ2;
  1196.         types[2] = (char *) res;
  1197.         break;
  1198.     default:
  1199. #ifdef DEBUG
  1200.         zpnod(name_node);
  1201. #endif
  1202.         chaos("unexpected node in find_renamed_types");
  1203.     }
  1204.     return types;
  1205. }
  1206.  
  1207. static Node make_rename_node(Symbol name, Node instance)  /*;make_rename_node*/
  1208. {
  1209.     /* Create a renaming node, for    use when a generic subprogram parameter
  1210.      * is instantiated with     an attribute or  an entry name. The rename node
  1211.      * of kind as_rename_sub_tr need not contain the spec node as this info
  1212.      * can be obtained by EXPAND from the symbol table but instead only contains
  1213.      * the unique name of the subprogram plus the instance info.
  1214.      */
  1215.  
  1216.     Node rename_node;
  1217.  
  1218.     rename_node = node_new(as_rename_sub_tr);
  1219.     N_AST2(rename_node) = instance;
  1220.     N_UNQ(rename_node) = name;
  1221.     return rename_node;
  1222. }
  1223.  
  1224. Symbol anon_proc_instance(Symbol g_name, Tuple sig, Symbol typ)
  1225. {
  1226.     /* When a generic subprogam is instantiated with an attribute or an
  1227.      * entry, we create a renaming declaration for an anonymous procedure.
  1228.      * The generic subprogram then renames this anonymous one.
  1229.      */
  1230.     Symbol    new_name, t, nam;
  1231.     Tuple    new_sig, tup, def;
  1232.     Fortup    ft1;
  1233.     int        kind;
  1234.     char    *id, *newat;
  1235.     char    *newat_str();
  1236.  
  1237.     new_name = sym_new(NATURE(g_name));
  1238.     newat = newat_str();
  1239.     dcl_put(DECLARED(scope_name), newat, new_name);
  1240.     TYPE_OF(new_name) = typ;
  1241.     ORIG_NAME(new_name) = strjoin(ORIG_NAME(g_name), newat);
  1242.  
  1243.     newscope(new_name);
  1244.     new_sig = tup_new(0);
  1245.  
  1246.     FORTUP(tup=(Tuple), sig, ft1);
  1247.         id = tup[1];
  1248.         kind = (int) tup[2];
  1249.         t = (Symbol) tup[3];
  1250.         def = (Tuple) tup[4];
  1251.         nam = find_new(id);
  1252.         NATURE(nam) = kind;
  1253.         TYPE_OF(nam) = t;
  1254.         SIGNATURE(nam) = def;
  1255.         new_sig = tup_with(new_sig, (char *) nam);
  1256.     ENDFORTUP(ft1);
  1257.     SIGNATURE(new_name) = new_sig;
  1258.     popscope();
  1259.  
  1260.     return new_name;
  1261. }
  1262.  
  1263. static void instantiation_code_with(Node node)
  1264. {
  1265.     /* add item to instantiation_code */
  1266.  
  1267.     int    n = (int) instantiation_code[0];
  1268.  
  1269.     if (instantiation_code_n >= n)
  1270.         instantiation_code = tup_exp(instantiation_code,
  1271.             (unsigned) n+INSTANTIATION_CODE_INC);
  1272.     instantiation_code[++instantiation_code_n] = (char *) node;
  1273. }
  1274.  
  1275. /* the following procedures formerly in undone.c have been put here
  1276.  * as the only references to them occurred in chapter 12 and they
  1277.  * should no longer be needed once that chapter fully translated.
  1278.  */
  1279. void is_identifier() {
  1280.     undone("is_identifier");
  1281. }
  1282. void is_tuple() {
  1283.     undone("is_tuple");
  1284. }
  1285.